HyperLib 1997 Winter - Disc 1/HYPERLIB-1997-Winter-CD1.ISO.7z/HYPERLIB-1997-Winter-CD1.ISO/オンラインウェア/PRG/ICProgKit 1.3.sit/ICProgKit1.3/Internet Config Source/ICLinkInSubs.p

Text File | 1995-11-04 | 14KB | 505 lines

unit ICLinkInSubs;

interface

    uses
{$ifc undefined THINK_Pascal}
        Types, Files, QuickDraw, Aliases,
{$endc}
        ICTypes, ICKeys;

{ Names changed to ICU to avoit name clash in .o files }

    function ICUEditPreferences (key: Str255; prefsfile: FSSpec): ICError;

    function ICUFindScheme (urlh: Handle; var scheme: Str255): ICError;
    function ICULaunchURL (helper: OSType; urlh: Handle): ICError;
    function ICUHaveProcessManager: ICError;
    function ICUHaveNewStandardFile: Boolean;
    function ICUFSSPecToFullPath (fs: FSSpec; var path: str255): OSErr;
    function ICUCanInteract: ICError;

    function ICFileSpecToFSSpec (filespec: ICFileSpecHandle; can_interact: Boolean; var fs: FSSpec): ICError;
    function FSSpecToICFileSpec (var fs: FSSpec; filespec: ICFileSpecHandle): OSErr;

implementation

    uses
{$ifc undefined THINK_Pascal}
        GestaltEqu, Errors, ToolUtils, Packages,
{$endc}
        Processes, AppleEvents;

    function ICUHaveProcessManager: ICError;
        var
            gv: longint;
    begin
        if (Gestalt(gestaltOSAttr, gv) = noErr) & (BTST(gv, gestaltLaunchControl)) then begin
            ICUHaveProcessManager := noErr;
        end
        else begin
            ICUHaveProcessManager := unimpErr;
        end; (* if *)
    end; (* HaveProcessManager *)

    function ICUCanInteract: ICError;
        var
            err: ICError;
            info: ProcessInfoRec;
            process_us, process_foreground: ProcessSerialNumber;
            result: boolean;
    begin
        err := noErr;
        if (err = noErr) & (ICUHaveProcessManager = noErr) then begin
            process_us.highLongOfPSN := 0;
            process_us.lowLongOfPSN := kCurrentProcess;
            err := GetFrontProcess(process_foreground);
            if err = noErr then begin
                err := SameProcess(process_us, process_foreground, result);
            end;
            if (err = noErr) & not result then begin
                err := errAENoUserInteraction;
            end;
        end;
        ICUCanInteract := err;
    end;

    function ICUHaveNewStandardFile: Boolean;
        var
            gv: longInt;
    begin
        ICUHaveNewStandardFile := (Gestalt(gestaltStandardFileAttr, gv) = noErr) & (BTST(gv, gestaltStandardFile58));
    end;

    function ICUHaveAliasManager: Boolean;
        var
            gv: longInt;
    begin
        ICUHaveAliasManager := (Gestalt(gestaltAliasMgrAttr, gv) = noErr) & (BTST(gv, gestaltAliasMgrPresent));
    end;

    function ICUFindProcess (creator, typ: OSType; var process: ProcessSerialNumber; var fs: FSSpec): boolean;
        var
            info: ProcessInfoRec;
            oe: OSErr;
            gv: longInt;
    begin
        ICUFindProcess := false;
        if ICUHaveProcessManager = noErr then begin
            process.highLongOfPSN := 0;
            process.lowLongOfPSN := kNoProcess;
            info.processInfoLength := sizeof(ProcessInfoRec);
            info.processName := nil;
            info.processAppSpec := @fs;
            while GetNextProcess(process) = noErr do begin
                if (GetProcessInformation(process, info) = noErr) & (info.processType = longInt(typ)) & (info.processSignature = creator) then begin
                    ICUFindProcess := true;
                    leave;
                end; (* if *)
            end; (* while *)
        end; (* if *)
    end; (* FindProcess *)

    function GetVolInfo (var name: str63; var vrn: integer; index: integer): OSErr;
        var
            pb: paramBlockRec;
            oe: OSErr;
    begin
        if (name <> '') & (name[length(name)] <> ':') then begin
            name := concat(name, ':');
        end; (* if *)
        pb.ioNamePtr := @name;
        pb.ioVRefNum := vrn;
        pb.ioVolIndex := index;
        oe := PBGetVInfo(@pb, false);
        if oe = noErr then begin
            vrn := pb.ioVRefNum;
        end; (* if *)
        GetVolInfo := oe;
    end; (* GetVolInfo *)

    function ConfirmAppl (creator: OSType; var fss: FSSpec): OSErr;
        var
            err: OSErr;
            info: FInfo;
    begin
        err := HGetFInfo(fss.vRefNum, fss.parID, fss.name, info);
        if err = noErr then begin
            if (info.fdType <> 'APPL') or (info.fdCreator <> creator) then begin
                err := afpItemNotFound;
            end; (* if *)
        end; (* if *)
        ConfirmAppl := err;
    end; (* ConfirmAppl *)

    function ScanVolume (creator: OSType; vref: integer; var fs: FSSpec): OSErr;
        var
            err: OSErr;
            file_index: integer;
            pbdt: DTPBRec;
            found: boolean;
    begin
        fs.name := '';
        pbdt.ioNamePtr := @fs.name;
        pbdt.ioVRefNum := vref;
        err := PBDTGetPath(@pbdt);
        if err = noErr then begin
            file_index := 1;
            found := false;
            repeat
                pbdt.ioIndex := file_index;
                pbdt.ioFileCreator := creator;
                err := PBDTGetAPPLSync(@pbdt);
                if err = noErr then begin
                    fs.vRefNum := vref;
                    fs.parID := pbdt.ioAPPLParID;
                    (* name is already put in by GetAPPL call *)
                    found := (ConfirmAppl(creator, fs) = noErr);
                end; (* if *)
                file_index := file_index + 1;
            until found or (err <> noErr);
        end; (* if *)
        ScanVolume := err;
    end; (* ScanVolume *)

    function ICUFindApplication (creator: OSType; var fs: FSSpec): OSErr;
        var
            err: OSErr;
            vol_index: integer;
            vref: integer;
            found: boolean;
    begin
        found := false;
        vol_index := 1;
        repeat
            vref := 0;
            err := GetVolInfo(fs.name, vref, vol_index);
            if err = noErr then begin
                err := ScanVolume(creator, vref, fs);
                if err = noErr then begin
                    found := true;
                end
                else begin
                    err := noErr;        (* swallow error so we continue with next volume *)
                end; (* if *)
            end; (* if *)
            vol_index := vol_index + 1;
        until found or (err <> noErr);
        if not found then begin
            err := afpItemNotFound;
            fs.vRefNum := 0;
            fs.parID := 2;
            fs.name := '';
        end; (* if *)
        ICUFindApplication := err;
    end; (* FindApplication *)

    function PrepareToLaunch (var theEvent: AppleEvent; tofront: boolean; var launchThis: LaunchParamBlockRec): ICError;
        var
            launchDesc: AEDesc;
    begin
        PrepareToLaunch := AECoerceDesc(theEvent, typeAppParameters, launchDesc);
        HLock(handle(launchDesc.dataHandle));
        launchThis.launchAppParameters := AppParametersPtr(launchDesc.dataHandle^);
        launchThis.launchBlockID := extendedBlock;
        launchThis.launchEPBLength := extendedBlockLen;
        launchThis.launchFileFlags := 0;
        launchThis.launchControlFlags := launchContinue + launchNoFileFlags;
        if not tofront then begin
            launchThis.launchControlFlags := launchThis.launchControlFlags + launchDontSwitch;
        end; (* if *)
    end; (* PrepareToLaunch *)

    function CreateGURLEvent (creator: OSType; urlh: Handle; var theEvent: AppleEvent): ICError;
        var
            targetAddress: AEDesc;
            err: ICError;
            junk: ICError;
            err2: ICError;
            s: signedByte;
    begin
        err := AECreateDesc(typeApplSignature, @creator, sizeof(creator), targetAddress);
        err2 := AECreateAppleEvent('GURL', 'GURL', targetAddress, kAutoGenerateReturnID, kAnyTransactionID, theEvent);
        if err = noErr then begin
            err := err2;
        end; (* if *)
        s := HGetState(urlh);
        HLock(urlh);
        err2 := AEPutKeyPtr(theEvent, keyDirectObject, typeChar, urlh^, GetHandleSize(urlh));
        HSetState(urlh, s);
        if err = noErr then begin
            err := err2;
        end; (* if *)
        if err <> noErr then begin
            junk := AEDisposeDesc(theEvent);
        end; (* if *)
        junk := AEDisposeDesc(targetAddress);
        CreateGURLEvent := err;
    end; (* CreateGURLEvent *)

    function CreateEditPrefEvent (creator: OSType; key: Str255; prefsfile: FSSpec; var theEvent: AppleEvent): ICError;
        var
            targetAddress: AEDesc;
            err: ICError;
            junk: ICError;
            err2: ICError;
    begin
        err := AECreateDesc(typeApplSignature, @creator, sizeof(creator), targetAddress);
        err2 := AECreateAppleEvent('ICAp', 'ICAp', targetAddress, kAutoGenerateReturnID, kAnyTransactionID, theEvent);
        if err = noErr then begin
            err := err2;
        end; (* if *)
        err2 := AEPutKeyPtr(theEvent, '----', 'TEXT', @key[1], length(key));
        if err = noErr then begin
            err := err2;
        end; (* if *)
        err2 := AEPutKeyPtr(theEvent, 'dest', 'fss ', @prefsfile, sizeof(prefsfile));
        if err = noErr then begin
            err := err2;
        end; (* if *)
        if err <> noErr then begin
            junk := AEDisposeDesc(theEvent);
        end; (* if *)
        junk := AEDisposeDesc(targetAddress);
        CreateEditPrefEvent := err;
    end; (* CreateEditPrefEvent *)

    function LaunchFSSpec (var fs: FSSpec; theEvent: AppleEvent): ICError;
        var
            launchThis: LaunchParamBlockRec;
            launchDesc: AEDesc;
            err: ICError;
    begin
        launchThis.launchAppSpec := @fs;
        err := PrepareToLaunch(theEvent, true, launchThis);
        if err = noErr then begin
            err := LaunchApplication(@launchThis);
        end; (* if *)
        if err = memFullErr then begin
            launchThis.launchControlFlags := bor(launchThis.launchControlFlags, launchUseMinimum);
            err := LaunchApplication(@launchThis);
        end; (* if *)
        LaunchFSSpec := err;
    end; (* LaunchFSSpec *)

    function SendEvent (theEvent: AppleEvent; creator: OSType): ICError;
        var
            err: ICError;
            psn: ProcessSerialNumber;
            app_fs: FSSpec;
            junk: ICError;
            reply: AppleEvent;
    begin
        if ICUFindProcess(creator, 'APPL', psn, app_fs) then begin
            junk := SetFrontProcess(psn);
            err := AESend(theEvent, reply, kAENoReply, kAEHighPriority, kNoTimeOut, nil, nil);
        end
        else begin
            err := ICUFindApplication(creator, app_fs);
            if err = noErr then begin
                err := LaunchFSSpec(app_fs, theEvent);
            end; (* if *)
        end; (* if *)
        SendEvent := err;
    end; (* SendEvent *)

    function ICUEditPreferences (key: Str255; prefsfile: FSSpec): ICError;
        var
            err: ICError;
            junk: ICError;
            theEvent: AppleEvent;
    begin
        err := ICUHaveProcessManager;
        if err = noErr then begin
            err := CreateEditPrefEvent(ICcreator, key, prefsfile, theEvent);
            if err = noErr then begin
                err := SendEvent(theEvent, ICcreator);
            end; (* if *)
            junk := AEDisposeDesc(theEvent);
        end; (* if *)
        ICUEditPreferences := err;
    end; (* EditPreferences *)

    function ICUFindScheme (urlh: Handle; var scheme: Str255): ICError;
        var
            err: ICError;
            tmp: Str15;
            ndx: longint;
    begin
        err := noErr;
        tmp := ':';
        ndx := Munger(Handle(urlh), 0, @tmp[1], length(tmp), nil, 0);
        if (ndx < 0) or (ndx > 255) then begin
            err := icNoURLErr;
        end; (* if *)
        if err = noErr then begin
{$push}
{$r-}
            scheme[0] := chr(ndx);
            BlockMove(urlh^, @scheme[1], ndx);
{$pop}
        end; (* if *)
        ICUFindScheme := err;
    end; (* FindScheme *)

    function ICULaunchURL (helper: OSType; urlh: Handle): ICError;
        var
            err: ICError;
            junk: ICError;
            theEvent: AppleEvent;
    begin
        err := ICUHaveProcessManager;
        if err = noErr then begin
            err := CreateGURLEvent(helper, urlh, theEvent);
            if err = noErr then begin
                err := SendEvent(theEvent, helper);
            end; (* if *)
            junk := AEDisposeDesc(theEvent);
        end; (* if *)
        ICULaunchURL := err;
    end; (* LaunchURL *)

    function FSpGetCatInfo (var fs: FSSpec; index: integer; var pb: CInfoPBRec): OSErr;
    begin
        pb.ioVRefNum := fs.vRefNum;
        pb.ioDirID := fs.parID;
        pb.ioNamePtr := @fs.name;
        pb.ioFDirIndex := index;
        FSpGetCatInfo := PBGetCatInfoSync(@pb);
    end;

    function ICUFSSPecToFullPath (fs: FSSpec; var path: str255): OSErr;
        var
            err: OSErr;
            pb: CInfoPBRec;
            s: str63;
    begin
        if fs.parID = 1 then begin
            path := concat(fs.name, ':');
        end
        else begin
            path := fs.name;
            while (err = noErr) & (fs.parID <> 1) do begin
                err := FSpGetCatInfo(fs, -1, pb);
                path := concat(fs.name, ':', path);
                fs.parID := pb.ioFlParID;
            end;
        end;
        ICUFSSPecToFullPath := err;
    end;

    function GetVolumeStuff (name: str31; date: longInt; var vrn: integer): OSErr;
        var
            err: OSErr;
            pb: HParamBlockRec;
            s: str255;
            pass, i: integer;
    begin
        for pass := 1 to 2 do begin
            i := 1;
            while true do begin
                pb.ioVolIndex := i;
                i := i + 1;
                pb.ioNamePtr := @s;
                s := '';
                err := PBGetVInfoSync(@pb);
                if err <> noErr then begin
                    leave;
                end;
                if IUEqualString(name, s) = 0 then begin
                    if (pass = 2) or (pb.ioVCrDate = date) then begin
                        leave;
                    end;
                end;
            end;
            if err = noErr then begin
                leave;
            end;
        end;
        if err = noErr then begin
            vrn := pb.ioVRefNum;
        end;
        GetVolumeStuff := err;
    end;

    function ICFileSpecToFSSpec (filespec: ICFileSpecHandle; can_interact: Boolean; var fs: FSSpec): ICError;
        var
            err: ICError;
            loe: longInt;
            attr: longint;
            pb: CInfoPBRec;
            alias: AliasHandle;
            aliasCount: integer;
            needsUpdate: Boolean;
            rule_mask: longInt;
    begin
        err := noErr;
        if (err = noErr) & (GetHandleSize(Handle(filespec)) < SizeOf(ICFileSpec)) then begin
            err := paramErr;
        end;
        if err = noErr then begin
            err := -1;
            if ICUHaveAliasManager & (filespec^^.alias.aliasSize <> 0) then begin
                alias := AliasHandle(filespec);
                err := HandToHand(Handle(alias));
                if err = noErr then begin
                    loe := Munger(Handle(alias), 0, nil, SizeOf(ICFileSpec) - SizeOf(AliasRecord), @loe, 0);
                    aliasCount := 1;
                    rule_mask := kARMSearch + kARMMountVol;
                    if can_interact & (ICUCanInteract <> noErr) then begin
                        rule_mask := rule_mask + kARMNoUI;
                    end;
                    err := MatchAlias(nil, rule_mask, alias, aliasCount, @fs, needsUpdate, nil, nil);
                end;
                DisposeHandle(Handle(alias));
            end;
            if err <> noErr then begin
                err := GetVolumeStuff(filespec^^.vol_name, filespec^^.vol_creation_date, fs.vRefNum);
                if err = noErr then begin
                    fs.parID := filespec^^.fss.parID;
                    fs.name := filespec^^.fss.name;
                    err := FSpGetCatInfo(fs, 0, pb);
                end;
            end;
        end;
        ICFileSpecToFSSpec := err;
    end;

    function FSSpecToICFileSpec (var fs: FSSpec; filespec: ICFileSpecHandle): OSErr;
        var
            alias: AliasHandle;
            pb: HParamBlockRec;
            err: OSErr;
            vname: Str63;
            loe: longInt;
    begin
        SetHandleSize(Handle(filespec), SizeOf(ICFileSpec));
        err := MemError;
        if err = noErr then begin
            pb.ioVRefNum := fs.vRefNum;
            pb.ioVolIndex := 0;
            pb.ioNamePtr := @vname;
            err := PBGetVInfoSync(@pb);
            if err = noErr then begin
                filespec^^.vol_creation_date := pb.ioVCrDate;
                filespec^^.vol_name := vname;
            end; (* if *)
            filespec^^.fss := fs;
            filespec^^.alias.userType := OSType(0);
            filespec^^.alias.aliasSize := 0;
        end;
        if (err = noErr) & ICUHaveAliasManager then begin
            err := NewAlias(nil, fs, alias);
            if err = noErr then begin
                err := HandAndHand(Handle(alias), Handle(filespec));
                if err = noErr then begin
                    loe := Munger(Handle(filespec), SizeOf(ICFileSpec) - SizeOf(AliasRecord), nil, SizeOf(AliasRecord), @loe, 0);
                end;
                DisposeHandle(Handle(alias));
            end;
            err := noErr;
        end;
        FSSpecToICFileSpec := err;
    end; (* FSSpecToICFileSpec *)

end. (* ICLinkInSubs *)